perm filename ACSHFT.F4[MSS,LCS] blob
sn#086986 filedate 1974-03-19 generic text, type T, neo UTF8
00100 SUBROUTINE ACSHFT(RX)
00200 COMMON /XRN/RN(4000)
00300 COMMON /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA
00400 1,DBST,NFLG,IXX,ISEMI,IQT,F(50),IAMP,K,KN,M,MODE,IBLA
00500 DIMENSION R(8,100)
00600 EQUIVALENCE (R,RN(3001)),(A,F(1)),(B,F(2)),(X,F(4)),
00700 1(Y,F(5)),(Z,F(6)),(JD,F(7)),(RN1,F(8)),(RH,F(9))
00800 Z=0
00900 L=K-1
01000 M=L-ABS(RX)
01100 JD=1
01200 RN1=99
01300 Y=-.23
01400 IF(RX.LT.0)GO TO 1
01500 L=M
01600 M=K-1
01700 JD=-1
01800 1 DO 2 N=M,L,JD
01900 C DOES IT HAVE AN ACCID?
02000 IF(AMOD(R(5,N),10.).EQ.0)GO TO 2
02100 A=R(6,N+1)
02200 B=R(6,N-1)
02300 IF(RN1.NE.99)GO TO 3
02400 C IS THIS THE FIRST ACCID?
02500 RN1=R(4,N)
02600 GO TO 6
02700 3 RH=R(4,N)
02800 IF(ABS(RH-RN1).LT.5)GO TO 4
02900 RN1=RH
03000 IF(Y.GT.0)Z=Z+.04
03050 C STOPS OCT., ETC. ACCIS BEING MOVED TO LEFT.
03100 Y=-.23+Z
03200 6 IF(A.EQ.20.OR.B.EQ.20)Y=Z
03300 4 X=0
03400 IF(R(6,N).EQ.20)X=-.24
03500 IF(R(6,N).EQ.10)X=.24
03600 Y=Y+.23
03700 IF(X+Y.LT.1)GO TO 7
03800 RN1=RH
03900 Z=Z+.04
04000 Y=0
04100 IF(A.EQ.20.OR.B.EQ.20)Y=.23
04200 C SO Y DOESN'T GET >1.
04300 Y=Y+Z
04400 7 X=X+Y
04450 IF(ABS(X-.04).LT..01)X=0
04500 IF(X.GE.0)GO TO 5
04600 Y=.23+Z
04700 X=Z
04800 5 R(5,N)=R(5,N)+X
04900 2 CONTINUE
05000 END
05100